(define-module (hbu program)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (rnrs bytevectors)
  #:use-module (guix hash)
  #:use-module (hbu fname)
  #:export (hbu-program))

;; https://www.gnu.org/software/guile/manual/html_node/File-Tree-Walk.html#File-Tree-Walk

(define (last l)
  (if (or (not l) (null? l))
      #f
      (if (null? (cdr l))
          (car l)
          (last (cdr l)))))

(define (remove!? thing list)
  ;; this does not look very nice
  ;; it's just to try to remove an element
  ;; and tell you if it did.
  ;;
  ;; ... not even used after writing it
  ;;
  (if (null? list)
      (values list #f)
      (if (equal? thing (car list))
          (values (cdr list) #t)
          (let ((deleted #f))
            (let loop ((l-1 list) (l-2 (cdr list)))
              (if (null? l-2)
                  #f
                  (if (equal? thing (car l-2))
                      (set-cdr! l-1 (cdr l-2))
                      (loop (cdr l-1) (cdr l-2)))))
            (values list deleted)))))

(define-syntax debug
  (syntax-rules ()
    ((debug (f args ...))
     (begin
       (format #t "DBG: ~a~%" `(f ,args ...))
       (f args ...)))))

(define (mkdir-if-not-exists dir)
  (unless (access? dir F_OK)
    (mkdir dir)))

(define (make-filename . args)
  (simplify-file-name (path-list->file-name args)))

;;;

(define (hash-file file)
  (format #f "~{~x~}"
          (bytevector->u8-list (file-sha256 file))))

(define (make-link-to-dumpfile dump h file)
  (system* "mkdir" "-p" (dirname file))
  (debug (symlink (make-filename (getcwd) dump h) ;; important that this is absolute
                  (make-filename file))))

(define (assert-linked-to-dump-hash dump name)
  ;; check that name really is a dump hash
  ;; TODO:
  ;; could also verify that it's a valid hash
  ;; or check that the hash exists in the dump
  (let ((h (basename name)))
    (unless (string=? name (make-filename (getcwd) dump h))
      (error (string-append "ERROR: " name " is not a link to a dump hash")))
    h))

(define (stash-file dump tidy file)
  (display "stashing file ")
  (display file)
  (newline)
  
  (let ((h (hash-file file))
        (name (basename file)))
    (display "moving to the dump...")
    (rename-file file (make-filename dump h))
    
    (display "creating symbolic link")
    (newline)
    (make-link-to-dumpfile dump h file)
    
    (display "adding link metadata")
    (newline)
    (cons file h)))

(define (perform-store-operation dump config)
  ;; version 2: add, move and delete
  
  (let ((tidy (car config))
        (files (cdr config)))

    ;; this is based off
    ;; <https://www.gnu.org/software/guile/manual/html_node/File-Tree-Walk.html#File-Tree-Walk>
    
    (define (enter? name stat result)
      ;; Skip version control directories.
      (not (member (basename name) '(".git" ".svn" "CVS"))))
    
    (define (leaf name stat result)
      ;; check that it's a symbolic link
      
      (case (stat:type stat)
        ((symlink)
         (let ((h (assert-linked-to-dump-hash dump (readlink name))))
           (if (member (cons name h) result)
               result ;(format #t "symblonik FINE ~a <~a>~%" h name)
               (begin
                 (format #t "symblonik MOVE/NEW ~a <~a>~%" h name)
                 (cons (cons name h) result)))))
        ((regular)
         (cons (stash-file dump tidy name) result))
        (else
         result)))
    
    ;; Count zero bytes for directories.
    
    (define (down name stat result) result)
    (define (up name stat result) result)

    ;; Likewise for skipped directories.

    (define (skip name stat result) result)

    ;; Ignore unreadable files/directories but warn the user.
    
    (define (error name stat errno result)
      (format (current-error-port) "warning: ~a: ~a~%"
              name (strerror errno))
      result)

    
    (set! files (filter! (lambda (p)
                           ;; check if was (re)moved
                           (let ((name (car p)))
                             (access? name F_OK)))
                         files))
    
    (cons tidy
          (file-system-fold enter? leaf down up skip error
                            files
                            tidy))))

(define (perform-curate-operation dump cmd-tidy config)
  ;; TODO: give a nice error if it's non-empty
  (let ((tidy (car config))
        (files (cdr config)))
    (for-each (lambda (p)
                (make-link-to-dumpfile dump (cdr p) (car p)))
              files)))

;;;

(define (hbu-last-config dump-path)
  ;; this doesn't work
  (last
   (scandir (make-filename dump-path "config")
            (lambda (name) (string-suffix? ".scm" name))
            (lambda (n1 n2)
              (let ((v1 (string->number (string-drop-right n1 (string-length ".scm"))))
                    (v2 (string->number (string-drop-right n2 (string-length ".scm")))))
                (< v1 v2))))))

(define (hbu-next-config dump-path)
  (let ((name (hbu-last-config dump-path)))
    (if name
        (let ((num (string->number (string-drop-right name (string-length ".scm")))))
          (make-filename dump-path
                         "config"
                         (string-append (number->string (+ num 1)) ".scm")))
        #f)))

(define (hbu-load-config dump-path)
  (let ((config (hbu-last-config dump-path)))
    (if config
        (call-with-input-file
            (make-filename dump-path "config" config)
          read)
        #f)))

(define (hbu-initialize dump-path tidy-path)
  (let* ((config `(,tidy-path))
         (config-dir (make-filename dump-path "config"))
         (config-file (make-filename config-dir "0.scm")))
    ;; create directories
    (mkdir-if-not-exists dump-path)
    (mkdir-if-not-exists config-dir)
    ;(mkdir-if-not-exists tidy-path)
    ;; create config file
    (call-with-output-file config-file
      (lambda (port)
        (write config port)
        (newline port)))))

(define (hbu-curate dump-path tidy-path)
  (let ((config (hbu-load-config dump-path)))
    (mkdir-if-not-exists tidy-path)
    (if config
        (perform-curate-operation dump-path tidy-path config)
        (hbu-initialize dump-path tidy-path))))

(define (hbu-store dump-path)
  (let ((config (hbu-load-config dump-path)))
    (unless config
      (error "no config file!"))
    (let* ((next-config-file (hbu-next-config dump-path))
           (new-config (perform-store-operation dump-path config)))
      (call-with-output-file next-config-file
        (lambda (port)
          (write new-config port)
          (newline port))))))

(define (hbu-program args)
  (match args
    (((or "c" "cu" "cur" "curate") dump-path tidy-path)
     (hbu-curate dump-path tidy-path))
    (((or "s" "st" "sto" "store") dump-path)
     (hbu-store dump-path))
    (else
     (format #t "not a valid command. try curate or store.~%"))))

